Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/fortran/f2c-stab.9/f2c-stab/f2c-stabs/f2c-stabs.el

Text File | 1996-03-31 | 43.7 KB | 1,205 lines

;; f2c-stabs - emacs aid for debugging fortran code compiled via f2c.
;;
;; Copyright (c) 1996 Harvey J. Stein <[e-mail]>, and
;; eventually <[e-mail]>
;; All Rights Reserved.
;;
;; This package is covered by the GNU GPL.  You can freely use and
;; distribute it as long as it stays under the GNU GPL, and as long as
;; you distribute all the corresponding source code, and as long as this
;; message and the above copyright notice remains.
;;
;; Introduction
;; ------------
;; Annoyances exist when using gdb to debug fortran code compiled via
;; f2c.  The problems are:
;;   -Name mangling.
;;       f2c mangles variable names in an effort to avoid name
;;       collisions.  For example, a local variable foo_bar must be
;;       accessed as foo_bar__ in gdb.  Worse is the common block
;;       handling.  Common blocks become global structures.  Variables
;;       foo and foo_x in common block bar must be accessed as
;;       bar_.foo and foo_.bar_x__, respectively.  This makes
;;       inspecting variable values annoying.
;;   -Array accessing.
;;       f2c declares all arrays to be 1 dimensional C arrays, and
;;       computes array indices by itself.  Sometimes, it will shift
;;       pointers around to avoid the need to add an offset when
;;       computing indices.  This makes it difficult to use gdb to
;;       determine the value of an array at a particular index -
;;       especially if the array is multidimensional.
;;   -Argument dereferencing.
;;       Aside from the above name mangling, local variables are
;;       accessed normally.  However, since arguments are passed by
;;       reference, when one inspects the values of arguments one must
;;       dereference them using the * operator.
;;   -Parameter access.
;;       f2c realizes the parameters - they never make it into the C
;;       code, and thus aren't visible to gdb.
;;
;; The correct solution to the above would be to
;;    a) alter the stab data in the .o files to properly reflect
;;       common block names, and
;;    b) teach gdb about f2c's name mangling.
;;
;; This could prove quite tricky and no one's bothered to do it yet.
;;
;; This file is a work-around for the above.  It gives functions for
;; loading symbol table data into emacs, teaches emacs f2c's name
;; mangling, and gives functions for interacting with gdb (when run
;; from within emacs) so that the above problems can be partially
;; circumvented.
;;
;; Usage
;; -----
;; (Make sure you read everything below before starting.  This could
;; be crucial to your sanity).
;;
;; When debugging, one can type a fortran expression into gdb, and
;; then do M-x f2c-gdb.  The f2c-gdb function prompts for a fortran
;; expression (keeping a history of the expressions you've evaluated)
;; converts it to the corresponding C code (that gdb can understand),
;; and asks gdb to evaluate it.  Thus, the value of the expression
;; appears in your gdb buffer.
;;
;; I typically bind this command to C-cC-v (V for Variable reference).
;;
;; Note that the Fortran expression can be any expression, as long as
;; it doesn't use exponentiation.
;;
;; For example, after giving the f2c-gdb command, one will see in the
;; minibuffer:
;;
;;    Evaluate expression:
;;
;; If you type in:
;;
;;          mat3[1,2,3]
;;
;; and hit return, f2c-gdb will look into the symbol tables to
;; determine how to access mat3(1,2,3), and will get gdb to print its
;; value.  After the command, the gdb interaction buffer will display
;; something like:
;;
;; (mat3[1,2,3]) = 16.123
;; (gdb)
;;
;; Note that f2c-gdb allows index ranging.  This means that f2c-gdb
;; will take things like the following expression:
;;
;;       mat3[2*(1:3)-1, 2:3, -2:-1]
;;
;; and cause gdb to display something like:
;; (mat3[((2*1)-1),2,-2]) = 123.121256
;; (mat3[((2*2)-1),2,-2]) = 0
;; (mat3[((2*3)-1),2,-2]) = 0
;; (mat3[((2*1)-1),3,-2]) = 123.121256
;; (mat3[((2*2)-1),3,-2]) = 123.121256
;; (mat3[((2*3)-1),3,-2]) = 123.126
;; (mat3[((2*1)-1),2,-1]) = 123.126
;; (mat3[((2*2)-1),2,-1]) = 133.1
;; (mat3[((2*3)-1),2,-1]) = 133.1
;; (mat3[((2*1)-1),3,-1]) = 133.1
;; (mat3[((2*2)-1),3,-1]) = 0
;; (mat3[((2*3)-1),3,-1]) = 19
;; (gdb)
;;
;; Note also that f2c-gdb allows indices to be expressions.  For
;; example, one could use f2c-gdb on:
;;
;;    mat3[i,j,type]
;;
;; or on:
;;
;;     mat3[-2:2,j,type]
;;
;; However, one may not use index ranging on an index containing a
;; variable.  So, vect[1:j] wouldn't work right.  Of course, one can
;; simulate things like vect[(j:j+10)] by vect[j+(0:10)].
;;
;; Note that the entire expression used is parsed and modified by
;; f2c-gdb before passing it back to gdb for evaluation.  Therefore,
;; one can nest things to one's hearts content.  For example, f2c-gdb
;; can handle expressions such as:
;;
;;     temp[bad_times[1:10], 1] - base_temp
;;
;; Setup
;; -----
;; Unfortunately, the above functionality comes at a price.  As I
;; mentioned above, one must load the symbol table data into emacs.
;;
;; Fortunately, there are tools for building the appropiate lisp
;; files.  If you have all the .f and .inc files that comprise your
;; code in the current directory, *and*, you don't have any .el files
;; that you need to keep around, then you can do:
;;
;;   rm *.el
;;   fts-f2si *.f *.inc
;;   make-f2c-stabs *.si
;;
;; The fts-f2si command reads all the Fortran files specified on the
;; command line and makes corresponding .si files (stands for
;; Subroutine Information) which contain information such as the local
;; variables, their types and dimensions, names of included files,
;; variables in common blocks, etc.
;;
;; The make-f2c-stabs command reads the .si files and outputs the
;; emacs elisp files needed for the f2c-gdb command.
;;
;; After doing this, everything should be automatic.  When you run gdb
;; from within emacs and give the f2c-gdb command, emacs will
;; automatically load all the necessary .el files from the current
;; directory.
;;
;; If things get munged, use the f2c-clear-stab-table to get emacs to
;; start from scratch again.
;;
;; If you don't have make-f2c-stabs, or can't get it to work (because
;; you didn't bother to download STk), you may use the following
;; functions to load the symbol table data into emacs:
;;
;;
;; (f2c-add-common-var common var &optional dimens offsets)
;;   Tells emacs that var is a variable in the named common block
;;   common.  If var is an array, then dimens should be supplied and
;;   it should be a list of the ending indices of the variable.  If
;;   the variable has indices which don't start at 1, one supply the
;;   offsets argument, which should be a list of the starting indices.
;;   Note that var can be a list of symbols instead of just one
;;   symbol.  This makes it easier to load a group of arrays with the
;;   same dimensions, or all the scalars.
;;
;; For example, if one's fortran code contains:
;;
;;      INTEGER*2 foo(3,4)
;;      COMMON /bar_none/ foo
;;
;; one must give the command:
;;
;;   (f2c-add-common-var 'bar_none 'foo '(3 4))
;;
;; For the common block:
;;
;;      INTEGER*2 foo(3,-2:4)
;;      COMMON /bar_none/ foo
;;
;; one must give the command:
;;
;;   (f2c-add-common-var 'bar_none 'foo '(3 4) '(1 -2))
;;
;;
;; Similarly, we have the functions:
;;
;; (f2c-add-local-var context var &optional dimens offsets)
;;
;;    for adding local variables, and
;;
;; (f2c-add-arg-var context var &optional dimens offsets)
;;
;;    for adding variables which are arguments.
;;
;; If you want to add a parameter (for convenient reference), use:
;;
;; (f2c-add-param context param value)
;;
;;
;; I must explain the above context argument.  All variable references
;; are interpreted with respect to the context in which they occur.
;; When the f2c-gdb command is given, it gets name of the function
;; that gdb is currently stopped in.  This function name is considered
;; to be the context in which symbols should be interpreted.  To
;; illustrate, here's some sample fortran code and the corresponding
;; symbol updating data:
;;
;;       SUBROUTINE EAT(FOOD, DRINK)
;;       REAL*8 FOOD(0:6, -5:10)
;;       REAL*8 DRINK(0:4, -5:8)
;;
;;       REAL*8  RESULTS(-5:5, 9:12)
;;       REAL*8  MORE_RESULTS(5, 10)
;;       INTEGER NUM_RESULTS
;;       PARAMETER (NUM_RESULTS = 66)
;;       INTEGER YET_MORE_RESULTS(5, 10)
;;       REAL*8  ALT_RESULTS(-5:5, -NUM_RESULTS:NUM_RESULTS)
;;       COMMON  /FOOD_BLOCK/ ALT_RESULTS
;;
;; Here's how the above would be loaded into emacs:
;;
;;    (f2c-add-arg-var 'eat 'food  '(6 10) '(0 -5))
;;    (f2c-add-arg-var 'eat 'drink '(4 8)  '(0 -5))
;;    (f2c-add-local-var 'eat 'results '(5 12) '(-5 9))
;;    (f2c-add-local-var 'eat '(more_results yet_more_results)
;;                            '(5 10))
;;    (f2c-add-param 'eat 'num_results 66)
;;    (f2c-add-common-var 'food_block 'alt_results '(-5 "-num_results")
;;                        '(5 "num_results"))
;;    (f2c-add-subcontext 'food 'food_block)
;;
;; There are two new things above which I haven't yet discussed.
;; Instead of giving one variable, one may give a list of variables
;; (assuming they all have the same dimensions and are declared in the
;; same subroutine, etc).
;;
;; Secondly, note the call to f2c-add-subcontext.  Each context
;; contains a list of subcontexts.  When emacs tries to interpret a
;; symbol reference, it first looks in the variables declared for the
;; current context.  If it can't find the reference, it looks in the
;; variables declared for the subcontexts of the current context.
;; This is done recursively (although it probably needn't be), so be
;; careful not to define context loops.
;;
;; Simple usage
;; ------------
;; The easiest way to use the above is to ignore all the contexts.
;; Generate a file which adds *all* variables (except for common
;; blocks) to the context *globals*.  Add common block variables
;; as specified above, and make the common block names subcontexts of
;; *globals*.  Then, load f2c-stabs & this stab data file you just
;; generated from your .emacs.
;;
;; This will make all variables always accessable, because when
;; f2c-gdb sees a context that hasn't been loaded, it automatically
;; tries to load it.  If it cannot, it defines a context record with
;; no variables and with *globals* as its only subcontext.
;;
;; The only problem with this is that when two subroutines have the
;; same variable declared in different ways, one one will be
;; accessable.
;;
;; One could get around this problem by using lower level stab table
;; manipulation functions to make a pseudoname for one of the
;; variables.  If you're this sophisticated, you can look at the code
;; below to figure out how to do this.
;;
;; High tech usage
;; ----------------
;; The high tech way (and the way that make-f2c-stabs operates) is to
;; use the above is to add everything to it's proper context.  One can
;; either do this all in one file, and load it from your .emacs file,
;; or one could get *really* fancy by using the following f2c-gdb
;; feature.
;;
;; When f2c-gdb trys to resolve a symbol, it checks to see if the
;; current context has been loaded yet.  If it hasn't it gets the
;; current file name from gdb, and tries to load it as a .el file.
;; For example, if gdb is currently debugging foo.f, then f2c-gdb will
;; try to load foo.f.elc and then foo.f.el.  It will look first in the
;; current directory, and then along the load-path.
;;
;; So, rather than throwing all definitions into emacs at startup, you
;; can parse files on an individual basis - all the definitions in
;; foo.f into foo.f.el, and all the definitions in bar.f into bar.f.el.
;; Emacs will automatically load the corresponding lisp code when
;; needed.
;;
;; Note that I don't autoload recursively, so in particular, you
;; should load common block declarations either at startup or when you
;; start up gdb.
;;
;; So, a convenient setup would be as follows:
;;
;; First process each include file.  Each include file foo.inc will
;; have a corresponding foo.inc.el.  Give each .inc its own context
;; (maybe with name equal to the name of the .inc file), and add all
;; the symbols in the .inc file as subcontexts for this context.
;; Then process each function.  Use (f2c-require 'foo.inc.el) at the
;; top of foobar.f.el if foobar.f includes foo.inc.  Within
;; foobar.f.el, use f2c-add-subcontext to add the inc's context to the
;; context for foobar.f.
;;
;;
;; Useful utility routines
;; -----------------------
;; (f2c-resolve-ref context var)
;; Will traverse the symbol table data looking for a declaration of
;; var in the specified context.  Returns the declaration record, or
;; nul if it wasn't found.
;;
;; (f2c-resolve-expr context expr)
;;  Will return the parsed version of expr, relative to the given
;;  context.
;;
;; (f2c-resolve-and-expand context expr)
;;  As above, but also does range expansion, and unparses the
;;  expressions.
;;
;; (f2c-resolve-ref-in-current-context var)
;; As above, but queries gdb for current context.
;;
;; (f2c-local-symbol-name var)
;; Mangles var as f2c would when var is a local variable.
;;
;; (f2c-global-symbol-name var)
;; Mangles var as f2c would when var is a global variable (i.e. - an
;; entry point name or common block name).
;;
;; (f2c-common-symbol-name common var)
;; Returns the mangled name for accessing var, when var is a member of
;; the specified common block.
;;
;;
;; (f2c-get-context-stab context)
;; Returns the symbol table for the specified context.
;;
;; (f2c-get-or-load-context-stab context)
;; Same as f2c-get-context-stab, but will try to load it if CONTEXT
;; isn't yet recorded.  If it can't even be loaded, an empty context
;; will be created for CONTEXT, with subcontext *globals*.
;;
;;
;; To Do
;; -----
;;   -Better expression parsing.  Use symbol resolution recursively to
;;    allow things like:
;;       foo[bar[1:3], 1+baz[2:4,i]]   (done v1.0).
;;   -Write a tool to generate f2c-stabs data files  (done v1.0).
;;   -Figure out how to get the current function from gdb. (done v1.0,
;;    but sometimes breaks)
;;   -Not getting correct context after user does an up in gdb buffer
;;    (done v1.0).
;;
;;   -Problem with parameters whose values are formed by other
;;    parameters.  Suppose parameter foo_bar is (+ (* bar baz) 3).  Then
;;    we need to resolve bar and baz before passing things to gdb.
;;    Since foo_bar's value is in the long-name slot of the stab data, and
;;    since when we rewrite expressions, we replace symbols by their
;;    long names, this seems to indicate that we should do this
;;    recursively - i.e. - don't replace foo_bar by (longname foo_bar),
;;    replace it by (f2c-rewrite-symbols (longname foo_bar)).  However,
;;    we can't do this in general, because if foo_bar is a local
;;    variable (for example), its long name will be foo_bar__.  When
;;    we pass this to f2c-rewrite-symbols, f2c-rewrite-symbols will
;;    think that this is a local variable (because it won't be in the
;;    symbol tables, and will convert it to foo_bar____!  So
;;    basically, it seems like we need to recursively expand
;;    parameters, yet we need to avoid this for other symbols.
;;    Ways to handle this:
;;       -expand parameters when they're loaded instead of when
;;        they're evaluated.  This should be ok as long as the load
;;        files have the parameters in the correct order, because
;;        parameters have to ultimately resolve to a number at
;;        declaration time.  However, this requires a 2nd more recursive
;;        version of f2c-rewrite-symbols for use when loading syms.
;;       -Add a type field in the stabs data, and have
;;        f2c-rewrite-symbols do recursive expansion for parameters
;;        but not for other variables.  This will potentially make
;;        f2c-rewrite-symbols alot worse than it already is.
;;    (sort of done v1.0 with an quick ugly hack - I followed the
;;    first way, but instead of writing a proper version of
;;    f2c-rewrite-symbols for it, I merely call the normal version
;;    over and over again until it either it doesn't change the
;;    expression or until I've called it 10 times.  I said it was
;;    ugly...)
;;
;;   -Entry points might not work so well...
;;
;;   -Even better expression parsing.  parcil doesn't quite match
;;    Fortran, tries to interpret "1d100" in elisp (which basically
;;    gets converted to a random number), and chokes on ".7".  A big
;;    plus would be had if one could convince parcil to deal with .7,
;;    and to leave all non-integer numbers alone (return them as
;;    strings).  You want to evaluate the integers so that expression
;;    reduction can be done.
;;
;;   Performance hacks one might or might not want to do.  It's not
;;   clear that all would work, or even that one would want to do
;;   these things.  For example, it might be tricky to avoid order
;;   dependencies when doing the first one.
;;   -It would be clever to make the subcontext list a list of
;;    pointers into other contexts, rather than a list of the symbol
;;    names of other contexts - would avoid alot of list scanning.
;;   -It would be clever to both do the above and to make the contexts
;;    themselves emacs variables.  Maybe context would correspond to
;;    variable *f2c-stabs:context*.  Or, *f2c-stabs* could be an
;;    obarray to use instead...  Do this and *all* scanning for
;;    contexts would be circumvented.
;;   -For *real* *hot* operation, hang all variable declarations off
;;    of symbols too.  Then, just access *f2c-stabs:context:variable*
;;    for the variable declaration.  If it doesn't exist, get the
;;    subcontext list from *f2c-stabs:context*, and check for the
;;    variable in the contexts listed.
;;   -The above hacks might be needed for really large symbol tables,
;;    but in that the symbol table is only scanned upon user
;;    invocation of f2c-gdb, it probably isn't necessary.
;;   -Integrate f2c-gdb into gud - get emacs to filter everything that
;;    gets passed to gdb, and do variable lookups and de-referencing
;;    on the fly.  This would be way cool.

(require 'parcil)
(require 'cl)
(require 'cl-19)

(if (< max-lisp-eval-depth 800)
    (setq max-lisp-eval-depth 800))


(defvar *f2c-stabs* '((*globals* () ())))
;;  Format is:
;; '((context ( (sub-c sub-c sub-c ...) (local-stab-table)))
;;   (context ( (sub-c sub-c sub-c ...) (local-stab-table)))
;;   ...))
;;  Local stab table format:
;;  ((var full-name dimen offset dereferencer)
;;   (var full-name dimen offset dereferencer)
;;   ...)

(defvar *f2c-require-list* ())
;; List of files that we've already loaded.  I don't use
;; require/provide, because of the way it uses symbols and because I
;; want to only load foo.f.elc & foo.f.el.  I don't want emacs to
;; strip the suffix and try to load foo.f.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Low level stab table manipulation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun f2c-get-or-load-context-stab (context)
  "Retreive a context-stab.  Load or create a dummy record if CONTEXT
isn't known"
  (let* ((cont-stab (f2c-get-context-stab context)))
    (cond (cont-stab            ; Context known.
       cont-stab)
      (t                ; Context unknown.  Try to load it.
       (f2c-require (f2c-current-file))
       (setq cont-stab (assoc context *f2c-stabs*))
       (cond (cont-stab        ; Context now know.
          cont-stab)
         (t            ; Context still unknown.  Make it up.
          (f2c-add-subcontext context '*globals*)
          (assoc context *f2c-stabs*)))))))

(defun f2c-require (file)
  (cond ((not (memq file *f2c-require-list*))
     (let ((load-path (cons () load-path)))
       (setq load-path (cons () load-path))
       (if (or (load (concat (symbol-name file) ".elc")
             t () t)
           (load (concat (symbol-name file) ".el")
             t () t))
           (setq *f2c-require-list*
             (cons file *f2c-require-list*)))))))


(defun f2c-get-context-stab (context)
  "Gets full stab table for CONTEXT."
  (assoc context *f2c-stabs*))

(defun f2c-context (context-stab)
  "Gets context name from a stab table CONTEXT-STAB."
  (nth 0 context-stab))

(defun f2c-subcontext (context-stab)
  "Gets subcontext list from a stab table CONTEXT-STAB."
  (nth 1 context-stab))

(defun f2c-stab-table (context-stab)
  "Gets variable declaration list from stab table CONTEXT-STAB."
  (nth 2 context-stab))

(defun f2c-var-data (stab-table var)
  "Looks in STAB-TABLE for declaration record for VAR."
  (assoc var stab-table))


;;; Breaking out data from a var record.
(defun f2c-var-name (var-data)
  (nth 0 var-data))

(defun f2c-long-name (var-data)
  (nth 1 var-data))

(defun f2c-dimen (var-data)
  (nth 2 var-data))

(defun f2c-offset (var-data)
  (nth 3 var-data))

(defun f2c-aref (var-data)
  (nth 4 var-data))


;;; Adding data
(defun f2c-add-context (context)
  "Creates the specified context if it doesn't exist."
  (if (not (assoc context *f2c-stabs*))
      (setq *f2c-stabs* (cons (list context nil nil)
                  *f2c-stabs*))))


(defun f2c-get-or-add-context (context)
  "Gets full stab table for specified context.  Creates the context if it doesn't exist."
  (let ((context-stab (f2c-get-context-stab context)))
    (cond ((not context-stab)
       (f2c-add-context context)
       (setq context-stab (f2c-get-context-stab context))))
    context-stab))

(defun f2c-add-subcontext (context sub-context)
  (let ((context-stab (f2c-get-or-add-context context)))
    (if (not (member sub-context (f2c-subcontext context-stab)))
    (setcdr context-stab
        (list (cons sub-context
                (f2c-subcontext context-stab))
              (f2c-stab-table context-stab))))))


(defun f2c-add-symbol (context var full-name &optional dimens offsets converter)
  "Args: (context var full-name &optional dimens offsets converter).
Adds specified var data to specified context.  Dimens is a list of the full
length of each dimension of the variable - nil if the var is not an array.
If the var is an array, offsets is the starting indices of the array.  Nil
indicates that all indices start at 1.  Var and full-name can be lists
of variables instead of just symbols.  The effect is to cause
f2c-add-symbol to add each var/full-name pair."
  (when (or (not (listp var))
        (not (listp full-name)))
    (setq var (list var))
    (setq full-name (list full-name)))
  (let ((context-stab (f2c-get-or-add-context context)))
    (mapcar* '(lambda (var full-name)
        (if (not (assoc var (f2c-stab-table context-stab)))
            (setcdr context-stab
                (list (f2c-subcontext context-stab)
                  (cons (f2c-make-stab-record
                     context var full-name
                     dimens offsets converter)
                    (f2c-stab-table
                     context-stab))))))
         var
         full-name)))

(defun f2c-make-stab-record (context var full-name dimens offsets converter)
  "Args: (context var full-name dimens offsets converter).
Makes a symbol table record containing the above data.  Dimens and
offsets are resolved in the specified context."
  (list var
    full-name
    (mapcar 'f2c-parse-dimension-part dimens)
    (mapcar 'f2c-parse-dimension-part offsets)
    converter))

(defun f2c-parse-dimension-part (dim)
  "Parses DIM, being careful about cases that DIM isn't a string, or
is an asterisk."
  (cond ((numberp dim)
     dim)
    ((string-match "^[ \t]*\\*[ \t]*$" dim)
      1)                ; A hack, but it works...
    (t
     (f2c-reduce (parcil dim)))))

;;(defun mapcar* (f &rest args)
;;  "Apply FUNCTION to successive cars of all ARGS, until one ends.
;;Return the list of results."
;;  (if (not (memq 'nil args))              ; If no list is exhausted,
;;      (cons (apply f (mapcar 'car args))  ; Apply function to CARs.
;;        (apply 'mapcar* f             ; Recurse for rest of elements.
;;           (mapcar 'cdr args)))))

(defun f2c-clear-stab-table ()
  "Clears stabs tables (in case they need to be reloaded."
  (interactive)
  (setq *f2c-stabs* '((*globals* () ())))
  (setq *f2c-require-list* '()))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; High level interface.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Adding data
(defun f2c-add-common-var (common var &optional dimens offsets)
"Adds COMMON as a f2c context, and adds VAR as a common block variable
in this context.  If DIMENS are given it should be a list of the upper
bounds of the indices of VAR.  In this case, VAR is assumed to be an
array.  If OFFSETS is given, it should be a list of the lower bounds
of the indices of VAR.  If OFFSETS isn't given, it's assumed that the
lower bounds are all one.  VAR may be a list of symbols, in which case
each one is added."
  (if (not (listp var)) (setq var (list var)))
  (f2c-add-symbol common
          var
          (mapcar '(lambda (v)
                 (f2c-common-symbol-name common v))
              var)
          (f2c-array-width dimens offsets)
          offsets
          'common-aref-form))


(defun f2c-add-local-var (context var &optional dimens offsets)
"Adds CONTEXT as a f2c context, and adds VAR as a local variable in
this context.  If DIMENS are given it should be a list of the upper
bounds of the indices of VAR.  In this case, VAR is assumed to be an
array.  If OFFSETS is given, it should be a list of the lower bounds
of the indices of VAR.  If OFFSETS isn't given, it's assumed that the
lower bounds are all one.  VAR may be a list of symbols, in which case
each one is added."
  (if (not (listp var)) (setq var (list var)))
  (f2c-add-symbol context
          var
          (mapcar 'f2c-local-symbol-name var)
          (f2c-array-width dimens offsets)
          offsets
          'common-aref-form))

(defun f2c-add-arg-var (context var &optional dimens offsets)
"Adds CONTEXT as a f2c context, and adds VAR as a subroutine argument
in this context.  If DIMENS are given it should be a list of the upper
bounds of the indices of VAR.  In this case, VAR is assumed to be an
array.  If OFFSETS is given, it should be a list of the lower bounds
of the indices of VAR.  If OFFSETS isn't given, it's assumed that the
lower bounds are all one.  VAR may be a list of symbols, in which case
each one is added."
  (if (not (listp var)) (setq var (list var)))
  (f2c-add-symbol context
          var
          (if dimens
              (mapcar 'f2c-local-symbol-name var)
            (mapcar 'f2c-arg-symbol-name var))
          (f2c-array-width dimens offsets)
          offsets
          'base-aref-form))

(defun f2c-add-param (context param value)
"Adds CONTEXT as a f2c context, and adds PARAM as a parameter in this
context having value VALUE.  gdb-f2c will replace top level
occurrences of PARAM with VALUE.  NOTE - unlike the other f2c-add
functions, PARAM may NOT be a list."
  (f2c-add-symbol context
          param
          ;; Too few hacks would make jack a dull boy...
          (f2c-parse-param-guy context value)
;;;          value
          nil
          nil
          nil))

;;; The following is used to parse parameter values.  We don't just
;;; call parcil, because it barfs on things like ".7".  This will
;;; hopefully allow gdb to evaluate such things instead.
;;; Unfortunately, if the user sticks .7 or 1d100 into his expression, he's doomed...
(defun f2c-parse-param-guy (context v)
  (cond ((numberp v)
     v)
    ((string-match "^[+-]?[0-9]+*[ \t]*$" v) ; an integer
     (string-to-number v))
     ;; Nasty regexp which hopefully matches arithmetical expressions, but leaves variables alone...
    ((string-match "^\\([ \t()+*/-]*[+-]?\\(\\([0-9]+\\.?[0-9]*\\|[0-9]*\\.[0-9]+\\)\\([dDeE][+-]?[0-9]+\\)?\\)[ \t()+*/-]*\\)*$" v)
      v)
    (t (do* ((i 1 (1+ i))
         (oldpv () pv)
         (pv (f2c-reduce (parcil v))
             (f2c-reduce (f2c-rewrite-symbols context pv))))
           ((or (> i 10) (equal pv oldpv)) pv)))))


(defun f2c-resolve-ref-in-current-context (var)
  "Returns the variable declaration data for VAR from the current context."
  (f2c-resolve-ref (gud-context) var))

(defun f2c-resolve-ref (context var)
  "Returns the variable declaration data from context CONTEXT for
variable VAR."
  (let* ((context-stab (f2c-get-or-load-context-stab context))
     (vd (f2c-var-data (f2c-stab-table context-stab) var)))
    (if vd
    vd
      (f2c-resolve-in-subcontext (f2c-context context-stab) var))))

(defun f2c-resolve-in-subcontext (context var)
  (let* ((context-stab (f2c-get-context-stab context))
     (vd (f2c-var-data (f2c-stab-table context-stab) var))
     (subcs (f2c-subcontext context-stab)))
    (if vd
    vd
      (while (and subcs (not vd))
    (setq vd (f2c-resolve-in-subcontext (car subcs) var))
    (setq subcs (cdr subcs)))
      vd)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Name mangling
;;;    Routines for converting fortran symbols to their f2c mangled
;;;    versions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun f2c-local-symbol-name (var)
  "If it has an underscore, append 2!"
  (let ((sv (symbol-name var)))
    (if (string-match "_" sv)
    (intern (concat sv "__"))
      var)))

(defun f2c-localize-name (var)
  (cond ((numberp var)
     var)
    ((symbolp var)
     (f2c-local-symbol-name var))
    (t
     (f2c-local-symbol-name (intern var)))))


(defun f2c-global-symbol-name (var)
  "If it has an underscore, append 2, otherwise append 1."
  (let ((sv (symbol-name var)))
    (if (string-match "_" sv)
    (intern (concat sv "__"))
      (intern (concat sv "_")))))


(defun f2c-common-symbol-name (common var)
  "Return symbol name for accessing var from common."
  (intern (concat (symbol-name (f2c-global-symbol-name common))
          "."
          (symbol-name (f2c-local-symbol-name var)))))

(defun f2c-arg-symbol-name (var)
  "Same as local symbol name, but dereference it!"
  (intern (concat "*"
          (symbol-name (f2c-local-symbol-name var)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Array ref functions.
;;;   Functions which convert array indices to an offset.
;;;   Note that instead of actually computing the offset, these
;;;   routines return a C expression which gdb can evaluate.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun base-aref-form (dim index &optional offset)
  "Returns a FORTRAN expression for computing the linear aref of a
shifted f2c array with dimension list DIM at index (list) INDEX.  The
optional argument OFFSET is ignored, but is included to make the
calling sequence identical to that of the function common-aref."
  (cond ((null index) 0)
    (t (ftn-f+ (car index)
          (ftn-f* (car dim)
         (base-aref-form (cdr dim) (cdr index)))))))

(defun common-aref-form (dim index &optional offset)
  "Returns a FORTRAN expression for computing the offset into an
unshifted f2c array with dim list DIM of index INDEX.  If offset is
supplied, it is used as the list of base indices for the array (as
opposed to the default of 1)."
  (ftn-f- (base-aref-form dim index) (common-offset-form dim offset)))

(defun common-offset-form (dim &optional offset)
  "Returns a FORTRAN expression for computing the offset of the first
element of a common block f2c array from index 0.  If the OFFSET list
is supplied, assumes array dimensions start at OFFSET instead of (1 1 ...)."
  (if (null offset) (setq offset (make-list (length dim) 1)))
  (base-aref-form dim offset))

(defun ftn-form-f+ (a b)
  (cond ((and (equal a 0) (equal b 0)) 0)
    ((equal a 0) b)
    ((equal b 0) a)
    ((and (numberp a) (numberp b)) (+ a b))
    (t  (format "(%s)+(%s)" a b))))

(defun ftn-form-f- (a b)
  (cond ((and (equal a 0) (equal b 0)) 0)
    ((equal a 0) (format "-(%s)" b))
    ((equal b 0) a)
    ((and (numberp a) (numberp b)) (- a b))
    (t (format "(%s)-(%s)" a b))))

(defun ftn-form-f* (a b)
  (cond ((or (equal a 0) (equal b 0)) 0)
    ((equal a 1) b)
    ((equal b 1) a)
    ((and (numberp a) (numberp b)) (* a b))
    (t (format "(%s)*(%s)" a b))))

(defun ftn-f+ (a b)
  (cond ((and (equal a 0) (equal b 0)) 0)
    ((equal a 0) b)
    ((equal b 0) a)
    ((and (numberp a) (numberp b)) (+ a b))
    (t  (list '+ a b))))

(defun ftn-f- (a b)
  (cond ((and (equal a 0) (equal b 0)) 0)
    ((equal a 0) (list '- b))
    ((equal b 0) a)
    ((and (numberp a) (numberp b)) (- a b))
    (t (list '- a b))))

(defun ftn-f* (a b)
  (cond ((or (equal a 0) (equal b 0)) 0)
    ((equal a 1) b)
    ((equal b 1) a)
    ((and (numberp a) (numberp b)) (* a b))
    (t (list '* a b))))

(defun f2c-array-width (dimens &optional offsets)
  (cond ((null dimens) ())
    (t (cons (f2c-one-width (car dimens) (car offsets))
         (f2c-array-width (cdr dimens) (cdr offsets))))))

(defun f2c-one-width (d &optional o)
  (cond ((null o) d)
    ((equal o 1) d)
    ((and (stringp o) (string-match "^[ \t]*1[ \t]*$" o))
     d)
    ((and (stringp d) (string-match "^[ \t]*\\*[ \t]*$" d))
     (error "f2c: Hit a bad dimension - check your f2c-stabs .el files."))
    (t (ftn-form-f+ 1 (ftn-form-f- d o)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Routines for snarfing symbols off of the current line
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun f2c-snarf ()
  "Reads expression from current line.  Return it as a string."
  (save-excursion
    (let* ((b (progn (beginning-of-line) (point-marker)))
       (e (progn (end-of-line) (point-marker))))
      (goto-char b)
      (if (not (re-search-forward "\\([^ \t]*[ \t]+\\)\\(.*\\)[ \t]*$" (1+ e) t))
      ()
    (let* ((md (match-data))
           (lmd (length md)))
      (buffer-substring (nth (- lmd 2) md)
                (nth (- lmd 1) md)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Interacting with gud.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun f2c-current-file ()
  "Queries gud for current file.  Result returned as a symbol."
  (intern (gud-current-file)))

(defun gud-current-file ()
  "Returns the file gud is currently in."
  (let ((frame (or gud-last-frame gud-last-last-frame)))
    (if (null (car frame))
    ""
      (file-name-nondirectory (car frame)))))

(defun gdb-context ()
  "Gets symbol name of current fcn from gdb.  Downcase it because
Fortran is not case sensitive.  Really ugly parsing of gdb response to
frame command."
  (let ((cur-frame (gud-info-command "frame")))
    ;; regexp to parse subroutine name out of gdb's response to frame
    ;; command.  Expect a line beginning with #<number>, followed
    ;; possibly by garbage (stack pointer?), followed by space,
    ;; subroutine name space open parenthesis.  At least, this is what
    ;; it seems to be.  Is this really the case?
    (cond ((string-match "^#[0-9]+.* \\([^ \t]+\\) ("
             cur-frame)
       (setq cur-frame (substring cur-frame
                      (match-beginning 1)
                      (match-end 1)))
       ;; Note the call to demangle-global.
       (intern (downcase (f2c-demangle-global cur-frame))))
      (t '*globals*))))

(fset 'gud-context (symbol-function 'gdb-context))

;; Special demangling for subroutine names because of the way f2c
;; deals with entry points.  If you have a subroutine foo_bar and entry
;; point foo_eat, you get 3 subroutines, foo_bar__, foo_bar__0_ and
;; foo_eat__.  The routines foo_bar__ and foo_eat__ just call
;; foo_bar__0_, so most of the time your actually in foo_bar__0_.
;; Thus, we special case this out, converting foo_bar__0_ to foo_bar,
;; which is the name of the context that the user would have used for
;; the symbols in both foo_bar and foo_eat.  Note, however, that there
;; are other problems involved.  If the entry point has

(defun f2c-demangle-global (name)
  (cond ((string-match ".*__0_$" name)
     (substring name 0 (- (length name) 4)))
    ((string-match ".*_0_$" name)
     (substring name 0 (- (length name) 3)))
    ((string-match ".*__$" name)
     (substring name 0 (- (length name) 2)))
    (t
     (substring name 0 (- (length name) 1)))))

;;; The following should be in gud...
(defvar gud-info-in-progress ())
(defvar gud-info-string "")

;;; According to the comments in gud.el, setting
;;; gud-delete-prompt-marker to point nowhere should prevent
;;; gud-basic-call from deleting the current prompt.  We want this
;;; because we're going to snarf up all the data.  However, this
;;; doesn't seem to work, so instead we'll have to save the old
;;; prompt, and reinsert it later.  The problem is that gud-basic-call
;;; resets gud-delete-prompt-marker automatically, so we don't get any
;;; control...  Thus, we can't use gud-basic-call, and must do the
;;; call by hand...  This should be included in gud.el - it'd allow
;;; much easier customization - people would be able to easily write
;;; elisp fcns to send commands to gud & interpret the results.  This
;;; would, for example, effectively give gdb a (cheezy) scripting
;;; language.
(defun gud-info-command (command)
  "Send CMD to gud and return result as a string.  Result includes the
prompt at the end."
  (interactive)
  (let* ((end (point))
     (old-filter (symbol-function 'gud-marker-filter))
         (gud-delete-prompt-marker (make-marker)))
    (unwind-protect
    (progn
      ;; Temporarily install our filter function.
      (gud-overload-functions
       '((gud-marker-filter . gud-info-filter)))
      ;; Issue the command to GDB.
      (gud-set-buffer)
      (process-send-string (get-buffer-process gud-comint-buffer)
                   (format "%s\n" command))
      (setq gud-info-in-progress t
        gud-info-string "")
      ;; Slurp the output.
      (while gud-info-in-progress
        (accept-process-output (get-buffer-process gud-comint-buffer))))
      ;; Restore the old filter function.
      (fset 'gud-marker-filter old-filter))
    ;; Protect against old versions of GDB.
    gud-info-string))

(defun gud-info-filter (string)
  (setq gud-info-string (concat gud-info-string string))
  (if (string-match comint-prompt-regexp gud-info-string)
      (progn
    (setq gud-info-in-progress nil)
    "")
    ""))

(defun gud-empty-filter (string)
  string)


(defun f2c-rewrite-symbols (context l)
  "Rewrites symbols in parsed expression list L."
  (cond ((null l) ())
    ((atom l) (let ((v (f2c-resolve-ref context l)))
            (if v (f2c-long-name v)
              (f2c-localize-name l))))
    ((eq (car l) 'aref)        ; Convert refs.
     (let ((v (f2c-resolve-ref context (nth 1 l))))
       (if v
           (list 'aref
             (f2c-long-name v)
             (f2c-rewrite-symbols context
                      (f2c-compute-offset v (cddr l))))
         (cons (car l)
           (mapcar (lambda (s)
                 (f2c-rewrite-symbols context s))
               (cdr l))))))
    (t (let ((v (f2c-resolve-ref context (nth 0 l)))); cvt fcns to arefs.
         (if v
         (list 'aref
               (f2c-long-name v)
               (f2c-rewrite-symbols context
                        (f2c-compute-offset v (cdr l))))
           (cons (car l)
             (mapcar (lambda (s)
                   (f2c-rewrite-symbols context s))
                 (cdr l))))))))

(defun f2c-all-numbers (l)
  (or (null l)
      (and (numberp (car l))
       (f2c-all-numbers (cdr l)))))

(defun f2c-reduce (l)
  (cond ((atom l) l)
    ((member (car l) '(+ - * /))
     (let ((red (mapcar 'f2c-reduce (cdr l))))
       (if (f2c-all-numbers red)
           (apply (car l) red)
         (cons (car l) red))))
    ((and (member (car l) '(progn prog1))
          (null (cddr l)))
     (f2c-reduce (cadr l)))
    (t (cons (car l)
         (mapcar 'f2c-reduce (cdr l))))))

(defun f2c-resolve-expr (context expr)
  "From within CONTEXT, parses EXPR, interpretes variables & reduces the expression.
Returns a parsed expression."
  (f2c-reduce (f2c-rewrite-symbols context
                   (parcil expr))))

(defun f2c-resolve-and-expand (context expr)
  "From within CONTEXT, converts EXPR to a form that GDB will understand.
Does range expansion."
  (f2c-expand-ranges (f2c-resolve-expr context expr)))

(defun f2c-expand-ranges (lexpr)
  (let* ((globals ())
     (gcount 0)
     (ranges ())
     (symexpr (unparcil (f2c-ranges-to-vars lexpr))))
    (f2c-expand-ranges-aux globals ranges symexpr)))

(defun f2c-ranges-to-vars (lexpr)
  (cond ((atom lexpr) lexpr)
    ((null lexpr) lexpr)
    ((eq (car lexpr) ':)
     (setq globals (cons (f2c-make-global) globals))
     (setq ranges (cons (cdr lexpr) ranges))
     (car globals))
    (t (cons (car lexpr)
         (mapcar 'f2c-ranges-to-vars
             (cdr lexpr))))))

(defun f2c-make-global ()
  (incf gcount)
  (concat "__f2cstabsglobal" (number-to-string gcount)))

(defun f2c-expand-ranges-aux (globals ranges symexpr)
  (let ((lsymexpr (list symexpr)))
  (loop for g in globals
    for r in ranges
    for start   = (car r)
    for end     = (cadr r)
    if (or (not (numberp start))
           (not (numberp end)))
    return (error "f2c-expand-ranges-aux:  Ranges must be integers, but found %s:%s." start end)
    for step    = (if (< start end) 1 -1)
    for gregexp = (concat ".*\\(" g "\\).*")
    do (setq lsymexpr (loop for expr in lsymexpr
                append (loop for i from start to end by step
                     if (not (string-match gregexp expr))
                     return (error "f2c-expand-ranges-aux: Missing iterator variable!")
                     collect (concat (substring expr 0
                                    (match-beginning 1))
                             (number-to-string i)
                             (substring
                              expr
                              (match-end
                               1))))))
    finally return lsymexpr)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; High level interface to gdb.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar f2c-gdb-history ())

(defvar f2c-minibuffer-local-map nil
  "Keymap for minibuffer prompting of f2c-gdb command.")
(if f2c-minibuffer-local-map
    ()
  (setq f2c-minibuffer-local-map (copy-keymap minibuffer-local-map))
  (define-key
    f2c-minibuffer-local-map "\C-i" 'f2c-dynamic-complete))

(defun f2c-dynamic-complete ()
  "Perform completion in minibuffer on f2c symbol preceding  point."
  (interactive)
  (let ((stub ""))
    (if (string-match "[0-9a-zA-Z_]+$" (buffer-substring (point-min) (point)))
    (setq stub (buffer-substring (1+ (match-beginning 0)) (1+ (match-end 0)))))
    (comint-dynamic-simple-complete stub
                    (mapcar 'symbol-name (f2c-known-vars (gud-context))))))

(defun f2c-known-vars (context)
  (let ((cc (f2c-get-or-load-context-stab context)))
    (apply 'append
       (cons
        (mapcar 'f2c-var-name
            (f2c-stab-table cc))
        (mapcar 'f2c-known-vars
            (f2c-subcontext cc))))))


(defun f2c-gdb (expr)
  "Convert Fortran EXPRESSSION to a form that GDB can understand, and
have gdb evaluate it."
  (interactive
   (list (read-from-minibuffer "Evaluate expression: "
                   (if (consp f2c-gdb-history)
                   (car f2c-gdb-history)
                 "")
                   f2c-minibuffer-local-map nil
                   '(f2c-gdb-history . 1))))
;;; Switch to debugger buffer so that stabs data comes in from correct
;;; directory.
  (gud-set-buffer)            ; Is this needed?
  (set-buffer gud-comint-buffer)
  (switch-to-buffer gud-comint-buffer)

;;; Note - Must do all resolution before clearing prompt.  This is
;;; because resolution can force a call to gud-context, which in turn
;;; calls gud-info-command, which expects to see a prompt when the
;;; command is done.  If the prompt doesn't come through, it just sits
;;; there waiting for more input from the gud process.   Man, did that
;;; take a long time to track down...
  (let* ((context (gud-context))
     (eval-strings (f2c-resolve-and-expand context expr))
     (disp-strings (f2c-expand-ranges (f2c-reduce (parcil expr))))
;;     (disp-strings eval-strings)
     )
    (unwind-protect
    (progn (gud-basic-call "set prompt\n")
           (mapcar* 'f2c-gud-print-string
              disp-strings
              eval-strings))
      (gud-send "set prompt (gdb) \n"))))

(defun f2c-gdb-eval-region (min max)
  "Convert marked expression to a form that GDB can understand, and
have gdb evaluate it.  Useful if you come up with some sort of
f2c-grab-expresion-around-point."
  (interactive "r")
  (f2c-gdb (buffer-substring min max)))

(defun f2c-gdb-snarf ()
  "Reads expression from current line & gets gdb to print value."
  (interactive)
  (f2c-gdb (f2c-snarf)))


(defun gud-send (s)
  (process-send-string (get-buffer-process gud-comint-buffer)
               s))

(defun f2c-gud-print-nicely (disp strng)
    (gud-set-buffer)
    ;; Use gud-basic-call to remove prompt & turn off prompting!
    (unwind-protect
    (progn (gud-basic-call "set prompt\n")
           (f2c-gud-print-string disp strng))
      (gud-send "set prompt (gdb) \n")))

(defun f2c-gud-print-string (disp strng)
  (gud-send (format "echo %s = \n" disp))
  (gud-send (format "output %s\n" strng))
  (gud-send "echo \\n\n"))



(defun f2c-gud-print (var-data ref)
  (cond ((or (null ref)
         (null (f2c-dimen var-data))
         (null (f2c-aref var-data)))
     ;; Just a simple variable!!!
     (gud-send (format "echo %s = \n" (f2c-var-name var-data)))
     (gud-send (format "output %s\n" (f2c-long-name var-data))))
    (t
     ;; An array reference.
     (gud-send (format "echo %s%s = \n"
               (f2c-var-name var-data)
               ref))
     (gud-send (format "output %s[%s]\n"
               (f2c-long-name var-data)
               (f2c-compute-offset var-data ref)))))
  (gud-send "echo \\n\n"))

(defun f2c-compute-offset (var-data ref)
  (funcall (f2c-aref var-data)
       (f2c-dimen var-data)
       ref
       (f2c-offset var-data)))

(provide 'f2c-stabs)